home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 2002 November / SGI Freeware 2002 November - Disc 1.iso / dist / fw_exmh.idb / usr / freeware / lib / exmh-2.5 / html_head.tcl.z / html_head.tcl
Text File  |  2002-07-08  |  10KB  |  328 lines
  1. # head.tcl --
  2. # Manage the information in the HTML header.
  3. # This is not displayed and editted like the HTML body.
  4. # Instead, it is maintained as a property sheet so users cannot
  5. # screw up the header when editting the body.
  6.  
  7. proc Head_Reset {win} {
  8.     upvar #0 Head$win head
  9.     global env
  10.     if [catch {set head(author)} author] {
  11.     if [catch {set env(USER)} author] {
  12.         if [catch {set env(LOGUSER)} autor] {
  13.         set author ""
  14.         }
  15.     }
  16.     }
  17.     catch {unset head}
  18.     array set head [list    \
  19.     author    $author        \
  20.     title    (untitled)    \
  21.     bodyparam {}        \
  22.     ]
  23. }
  24. proc Head_New {win} {
  25.     upvar #0 Head$win head
  26.     return [list \
  27.     {title (untitled)}        \
  28.     [list author $head(author)]    \
  29.     {comment {}}            \
  30.     ]
  31.  
  32. }
  33. # Save the title text
  34. proc HMtag_title {win param textVar} {
  35.     upvar $textVar text
  36.     HeadTitle $win [string trim $text]
  37.     WinHistoryAdd $win [string trim $text]
  38.     set text ""    ;# Prevent text display
  39. }
  40. proc HeadTitle {win title} {
  41.     upvar #0  Head$win head
  42.     set head(title) $title
  43.     set top [winfo toplevel $win]
  44.     if {[winfo class $top] == "Html"} {
  45.     wm title [winfo toplevel $win] $title
  46.     wm iconname [winfo toplevel $win] $title
  47.     }
  48. }
  49.  
  50. proc HMtag_/title {win param textVar} {
  51.     upvar $textVar text ; set text [string trimleft $text]
  52. }
  53. proc HMtag_html {win param textVar} {
  54.     upvar $textVar text ; set text [string trimleft $text]
  55. }
  56. proc HMtag_/html {win param textVar} {
  57.     upvar $textVar text ; set text ""
  58. }
  59. proc HMtag_head {win param textVar} {
  60.     upvar $textVar text ; set text [string trimleft $text]
  61.     upvar #0 Head$win head
  62.     set head(inBody) 0
  63. }
  64. proc HMtag_/head {win param textVar} {
  65.     upvar #0 Head$win head
  66.     upvar $textVar text ; set text [string trimleft $text]
  67.     set head(inBody) 1
  68. }
  69. proc HMtag_body {win param textVar} {
  70.     upvar #0 Head$win head
  71.     upvar #0 HM$win var
  72.     
  73.     HMextract_param $param bgcolor head(bgcolor)
  74.     HMextract_param $param text head(foreground)
  75.     HMextract_param $param link head(c_link)
  76.     HMextract_param $param alink head(c_alink)
  77.     # Now, default any that werent in the html...
  78.     if {![info exists head(foreground)]} {
  79.     set head(foreground) [option get $win foreground Text]
  80.     }
  81.     if {![info exists head(bgcolor)]} {
  82.     set head(bgcolor) [option get $win background Text]
  83.     }
  84.     if {![info exists head(c_alink)]} {
  85.     set head(c_alink) [option get $win c_alink Text]
  86.     }
  87.     if {![info exists head(c_link)]} {
  88.     set head(c_link) [option get $win c_link Text]
  89.     }
  90.     # Ignoring vlink, background
  91.     set head(bodyparam) $param
  92.     if {[info exists var(S_exmhpart)]} {
  93.     Head_ColorPart $win [MimeLabel $var(S_exmhpart) part]
  94.     } else {
  95.     Head_SetColors $win $win
  96.     }
  97.     upvar $textVar text ; set text [string trimleft $text]
  98.     set head(inBody) 1
  99. }
  100. proc Head_ResetColors {win} {
  101.     $win tag configure link -foreground [Widget_ColorDefault $win c_link] \
  102.     -underline 1
  103.     $win config -background [Widget_ColorDefault $win background]
  104.     $win config -highlightbackground \
  105.     [Widget_ColorDefault $win highlightBackground]
  106.     $win config -foreground [Widget_ColorDefault $win foreground]
  107. }
  108. proc Head_SetColors {win w} {
  109.     upvar #0 Head$win head
  110.  
  111.     if {([winfo class $w] == "Entry") || ([winfo class $w] == "Dialog") ||
  112.         (([winfo class $w] == "Text") &&
  113.          ([winfo class [winfo parent $w]] == "Textarea"))} {
  114.     return    ;# Keep input form elements the original color...
  115.     }
  116.     # Now, set some colors...
  117.     if {[catch {$w config -background $head(bgcolor)}] &&
  118.         [catch {$w config -background #$head(bgcolor)}]} {
  119.     # do nothing
  120.     }
  121.     if {[catch {$w config -highlightbackground $head(bgcolor)}] &&
  122.         [catch {$w config -highlightbackground #$head(bgcolor)}]} {
  123.     # do nothing
  124.     }
  125.     if {[catch {$w config -foreground $head(foreground)}] &&
  126.         [catch {$w config -foreground #$head(foreground)}]} {
  127.     # do nothing
  128.     }
  129.     if {[catch {$w tag configure link -foreground $head(c_link)}] &&
  130.         [catch {$w tag configure link -foreground #$head(c_link)}]} {
  131.     # do nothing
  132.     }
  133.     foreach child [winfo children $w] {
  134.     Head_SetColors $win $child
  135.     }
  136. }
  137. proc Head_ColorPart {w tag} {
  138.     upvar #0 Head$w head
  139.  
  140.     if {[catch {$w tag config $tag -background $head(bgcolor)}] &&
  141.         [catch {$w tag config $tag -background #$head(bgcolor)}]} {
  142.     # do nothing
  143.     }
  144.     if {[catch {$w tag config $tag -foreground $head(foreground)}] &&
  145.         [catch {$w tag config $tag -foreground #$head(foreground)}]} {
  146.     # do nothing
  147.     }
  148.     if {[catch {$w tag configure link -foreground $head(c_link)}] &&
  149.         [catch {$w tag configure link -foreground #$head(c_link)}]} {
  150.     # do nothing
  151.     }
  152. }
  153. proc Head_Color {win w islink} {
  154.     upvar #0 Head$win head
  155.     if {[catch {$w config -background $head(bgcolor)}] &&
  156.         [catch {$w config -background #$head(bgcolor)}]} {
  157.     # do nothing
  158.     }
  159.     if $islink {
  160.     if {[catch {$w config -highlightbackground $head(c_link)}] &&
  161.         [catch {$w config -highlightbackground #$head(c_link)}]} {
  162.         $w config -highlightbackground blue
  163.     }
  164.     } else {
  165.     if {[catch {$w config -highlightbackground $head(bgcolor)}] &&
  166.         [catch {$w config -highlightbackground #$head(bgcolor)}]} {
  167.         # do nothing
  168.     }
  169.     }
  170. }
  171. proc HMtag_/body {win param textVar} {
  172.     upvar $textVar text ; set text ""
  173. }
  174. proc Head_BodyEdit {win} {
  175.     upvar #0 Head$win head
  176.     set new [Dialog_Htag $win {body bgcolor= text= background= alink= vlink= link=} $head(bodyparam) \
  177.     "These parameters affect the overall page display"]
  178.     if [string length $new] {
  179.     set text ""
  180.     Head_ResetColors $win
  181.     HMtag_body $win [lindex $new 1] text
  182.     }
  183. }
  184. proc HMtag_meta {win param textVar} {
  185.     upvar #0 Head$win head
  186.     upvar $textVar text ; set text [string trimleft $text]
  187.     lappend head(meta) $param
  188. }
  189. proc HMtag_link {win param textVar} {
  190.     upvar #0 Head$win head
  191.     lappend head(link) $param
  192. }
  193. proc HMtag_!doctype {win param textVar} {
  194.     upvar #0 Head$win head
  195.     upvar $textVar text ; set text [string trimleft $text]
  196.     set head(doctype) $param
  197. }
  198.  
  199. # A pair of pseudo tags are added automatically as the 1st and last html
  200. # tags in the document.  The default is <HMstart> and </HMstart>.
  201. # Append enough blank space at the end of the text widget while
  202. # rendering so HMgoto can place the target near the top of the page,
  203. # then remove the extra space when done rendering.
  204.  
  205. proc HMtag_hmstart {win param textVar} {
  206.     upvar #0 HM$win var
  207.     upvar $textVar text ; set text [string trimleft $text]
  208.     $win mark gravity $var(S_insert) left
  209.     $win insert end "\n " last
  210.     $win mark gravity $var(S_insert) right
  211. }
  212.  
  213. proc HMtag_/hmstart {win param textVar} {
  214.     upvar $textVar text ; set text ""
  215.     $win delete last.first end
  216. }
  217.  
  218. # Output wrapper for file output
  219.  
  220. proc Head_Output {win {frameset 0}} {
  221.     upvar #0 Head$win head
  222.     set s ""
  223.     if [info exists head(doctype)] {
  224.     append s "<!Doctype $head(doctype)>\n"
  225.     }
  226.     append s <Html>\n<Head>\n<Title>$head(title)</Title>\n
  227.     set author 0
  228.     if [info exists head(comments)] {
  229.     foreach item $head(comments) {
  230.         regsub -- -+$ $item {} item
  231.         set item [string trim $item]
  232.         if {[string length $item] == 0} {
  233.         continue
  234.         }
  235.         if [regexp -nocase {author:} $item] {
  236.         append s "<!-- Author: $head(author) -->\n"
  237.         set author 1
  238.         } else {
  239.         append s "<!-- $item -->\n"
  240.         }
  241.     }
  242.     }
  243.     if {! $author && [info exists head(author)]} {
  244.     set author [string trim $head(author)]
  245.     if {[string length $author] > 0} {
  246.         append s "<!-- Author: $head(author) -->\n"
  247.     }
  248.     }
  249.     foreach {key label} {meta META link LINK} {
  250.     if [info exists head($key)] {
  251.         foreach item $head($key) {
  252.         append s "<$label $item>\n"
  253.         }
  254.     }
  255.     }
  256.     if {!$frameset} {
  257.     append s </Head>\n
  258.     append s <[string trim "Body $head(bodyparam)"]>\n
  259.     }
  260.     return $s
  261. }
  262.  
  263. proc Head_OutputTail {win} {
  264.     return \n</Body>\n</Html>\n
  265. }
  266. proc Head_Display {win} {
  267.     upvar #0 Head$win head
  268.  
  269.     set entryList [list [list title $head(title)]]
  270.     lappend entryList [list author $head(author)]
  271.     if [info exists head(doctype)] {
  272.     lappend entryList [list doctype $head(doctype)]
  273.     }
  274.  
  275.     if [info exists head(comments)] {
  276.     set i ""
  277.     foreach item $head(comments) {
  278.         if ![regexp -nocase author: $item] {
  279.         lappend entryList [list Comment$i $item]
  280.         if {$i == {}} {set i 1} else {incr i}
  281.         }
  282.     }
  283.     }
  284.     if [info exists head(meta)] {
  285.     set i ""
  286.     foreach item $head(meta) {
  287.         lappend entryList [list Meta$i $item]
  288.         if {$i == {}} {set i 1} else {incr i}
  289.     }
  290.     }
  291.     DialogEntry $win .head "HTML Head Information" [list Head_Update $win] $entryList [list HeadDialogHook $win .head]
  292. }
  293. proc HeadDialogHook { win frame f } {
  294.     upvar #0  Head$win head
  295.     set b $f.b
  296.     button $b.meta -text "Add meta" -command [list HeadAddMeta $win $frame]
  297.     pack $b.meta -side right
  298.     button $b.comment -text "Add comment" -command [list HeadAddComment $win $frame]
  299.     pack $b.comment -side right
  300. }
  301.  
  302. proc Head_Update {win values} {
  303.     upvar #0  Head$win head
  304.     array set head $values
  305.     foreach {key pat} {comments Comment* meta Meta*} {
  306.     set head($key) {}
  307.     foreach ix [lsort [array names head $pat]] {
  308.         if {[string length [string trim $head($ix)]]} {
  309.         lappend head($key) $head($ix)
  310.         }
  311.     }
  312.     }
  313.     HeadTitle $win $head(title)
  314. }
  315.  
  316. proc HeadAddMeta {win frame} {
  317.     upvar #0  Head$win head
  318.     set i {}
  319.     catch {set i [llength $head(meta)]}
  320.     DialogEntryAdd $win $frame Meta$i "New"
  321. }
  322. proc HeadAddComment {win frame} {
  323.     upvar #0  Head$win head
  324.     set i {}
  325.     catch {set i [llength $head(comments)]}
  326.     DialogEntryAdd $win $frame Comment$i "New"
  327. }
  328.